home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / tooltalk / tooltalk-util.el.z / tooltalk-util.el
Encoding:
Text File  |  1998-05-21  |  8.9 KB  |  269 lines
  1. ;;; -*- Mode: Emacs-Lisp -*-
  2. ;;;
  3. ;;; Emacs Tooltalk Utility Functions
  4. ;;;
  5. ;;; @(#)tooltalk-util.el 1.7 93/12/07
  6.  
  7.  
  8. (defun initialize-tooltalk-message-arg (msg n mode value vtype)
  9.   "Initialize the Nth tooltalk message argument of MSG.
  10. A new argument is created if necessary.  No attempt to distinguish
  11. between strings that contain binary data and ordinary strings is made;
  12. all non integer argument values are converted to a string (if not a
  13. string already) and loaded with tt_message_arg_val_set().
  14. Applications that need to put binary data into a ToolTalk message
  15. argument should initialize the argument with:
  16.  
  17.    (set-tooltalk-message-attribute bin-string msg 'arg_bval arg-n)"
  18.   (let ((n-args-needed
  19.      (- (1+ n) (get-tooltalk-message-attribute msg 'args_count))))
  20.     (while (> n-args-needed 0)
  21.       (add-tooltalk-message-arg msg mode vtype)
  22.       (setq n-args-needed (1- n-args-needed))))
  23.  
  24.   (cond
  25.    ((integerp value) 
  26.     (set-tooltalk-message-attribute value msg 'arg_ival n))
  27.    ((stringp value)
  28.     (set-tooltalk-message-attribute value msg 'arg_val n))
  29.    (t
  30.     (error "The value specified for msg %s argument %d, %s, must be a string or an integer"
  31.        (prin1-to-string msg)
  32.        n
  33.        (prin1-to-string value)))))
  34.  
  35.  
  36.  
  37. (defconst tooltalk-arg-mode-ids 
  38.   (list 'TT_IN 'TT_OUT 'TT_INOUT TT_IN TT_OUT TT_INOUT))
  39.  
  40. (defun initialize-tooltalk-message/pattern-args (initfn msg args)
  41.   "Apply INITFN to each the position mode value and type of
  42. each argument in the list.  The value of INITFN should be either
  43. 'initialize-tooltalk-message-arg or 'initialize-tooltalk-pattern-arg.
  44. See `make-tooltalk-message' for a description of how arguments are specified.
  45. We distinguish the short form for arguments, e.g. \"just-a-value\", 
  46. from the long form by checking to see if the argument is a list whose
  47. car is one of the ToolTalk mode values like TT_INOUT."
  48.   (let ((n 0))
  49.     (while args
  50.       (let* ((arg (car args))
  51.          (long-form 
  52.           (and (consp arg) 
  53.            (member (car arg) tooltalk-arg-mode-ids)))
  54.          (mode 
  55.           (if long-form (car arg) TT_IN))
  56.          (value 
  57.           (cond
  58.            ((not long-form) arg)
  59.            ((cdr arg) (car (cdr arg)))
  60.            (t "")))
  61.          (type
  62.           (cond
  63.            ((and long-form
  64.              (cdr (cdr arg)) 
  65.              (stringp (car (cdr (cdr arg)))))
  66.         (car (cdr (cdr arg))))
  67.            ((integerp value) "int")
  68.            (t "string"))))
  69.     (funcall initfn msg n mode value type))
  70.       (setq args (cdr args))
  71.       (setq n (1+ n)))))
  72.  
  73.  
  74. (defun initialize-tooltalk-message-attributes (msg attributes)
  75.   "Initialize the tooltalk message attributes.  The value of 
  76. attributes must be a property list in the same form as for 
  77. make-tooltalk-message.  This function can be used to reset
  78. an existing message or to initialize a new one.  See 
  79. initialize-tooltalk-message-args for a description of how
  80. arguments are initialized."
  81.   (let ((args attributes)
  82.     (initfn 'initialize-tooltalk-message-arg))
  83.     (while (and args (cdr args))
  84.       (let ((indicator (car args))
  85.         (value (car (cdr args))))
  86.     (if (eq indicator 'args)
  87.         (initialize-tooltalk-message/pattern-args initfn msg value)
  88.       (set-tooltalk-message-attribute value msg indicator)))
  89.       (setq args (cdr (cdr args))))))
  90.  
  91.  
  92. (defun make-tooltalk-message (attributes &optional no-callback)
  93.   "Create a tooltalk message and initialize its attributes.
  94. The value of attributes must be a list of alternating keyword/values, 
  95. where keywords are symbols that name valid message attributes.  
  96. For example:
  97.  
  98.   (make-tooltalk-message 
  99.     '(class TT_NOTICE
  100.       scope TT_SESSION
  101.       address TT_PROCEDURE
  102.       op \"do-something\"
  103.       args (\"arg1\" 12345 (TT_INOUT \"arg3\" \"string\"))))
  104.  
  105. Values must always be strings, integers, or symbols that
  106. represent Tooltalk constants.  Attribute names are the same as 
  107. those supported by set-tooltalk-message-attribute, plus 'args.
  108.  
  109. The value of args should be a list of message arguments where
  110. each message argument has the following form:
  111.  
  112.    (mode [value [type]]) or just value
  113.  
  114. Where mode is one of TT_IN, TT_OUT, TT_INOUT and type is a string.  
  115. If type isn't specified then \"int\" is used if the value is a 
  116. number otherwise \"string\" is used.  If only a value is specified 
  117. then mode defaults to TT_IN.  If mode is TT_OUT then value and 
  118. type don't need to be specified.  You can find out more about the 
  119. semantics and uses of ToolTalk message arguments in chapter 4 of the 
  120. Tooltalk Programmer's Guide.
  121.  
  122. The no-callback arg is a hack to prevent the registration of the
  123. C-level callback.  This hack is needed by the current SPARCworks
  124. tool startup mechanism.  Yucko."
  125.   (let ((msg (create-tooltalk-message no-callback)))
  126.     (initialize-tooltalk-message-attributes msg attributes)
  127.     msg))
  128.  
  129.  
  130. (defun describe-tooltalk-message (msg &optional stream)
  131.   "Print tooltalk message MSG's attributes and arguments to STREAM.
  132. This is often useful for debugging."
  133.   (let ((attrs
  134.      '(address
  135.        class
  136.        disposition
  137.        file
  138.        gid
  139.        handler
  140.        handler_ptype
  141.        object
  142.        op
  143.        opnum
  144.        otype
  145.        scope
  146.        sender
  147.        sender_ptype
  148.        session
  149.        state
  150.        status
  151.        status_string
  152.        uid 
  153.        callback)))
  154.     (terpri stream)
  155.     (while attrs
  156.       (princ (car attrs) stream)
  157.       (princ "  " stream)
  158.       (prin1 (get-tooltalk-message-attribute msg (car attrs)) stream)
  159.       (terpri stream)
  160.       (setq attrs (cdr attrs))))
  161.  
  162.   (let ((n (get-tooltalk-message-attribute msg 'args_count))
  163.     (i 0))
  164.     (while (< i n)
  165.       (princ "Argument " stream)
  166.       (princ i stream)
  167.       (princ "  " stream)
  168.       (let ((type (get-tooltalk-message-attribute msg 'arg_type i)))
  169.     (princ
  170.      (prin1-to-string
  171.       (list 
  172.        (get-tooltalk-message-attribute msg 'arg_mode i)
  173.        (if (equal type "int")
  174.            (get-tooltalk-message-attribute msg 'arg_ival i)          
  175.            (get-tooltalk-message-attribute msg 'arg_val i))
  176.        type))
  177.      stream))
  178.       (terpri stream)
  179.       (setq i (1+ i)))))
  180.  
  181.  
  182. (defun initialize-tooltalk-pattern-arg (pat n mode value vtype)
  183.   "Add one argument to tooltalk pattern PAT.
  184. No support for specifying pattern arguments whose value is a vector
  185. of binary data is provided."
  186.   (let ((converted-value   
  187.      (if (or (integerp value) (stringp value))
  188.          value
  189.        (prin1-to-string value))))
  190.     (add-tooltalk-pattern-arg pat mode vtype converted-value)))
  191.  
  192.  
  193. (defun initialize-tooltalk-pattern-attributes (pat attributes)
  194.   "Initialize tooltalk pattern PAT's attributes.
  195. ATTRIBUTES must be a property list in the same form as for
  196. `make-tooltalk-pattern'.  The value of each attribute (except 'category)
  197. can either be a single value or a list of values.  If a list of
  198. values is provided then the pattern will match messages with
  199. a corresponding attribute that matches any member of the list.
  200.  
  201. This function can be used to add attribute values to an existing
  202. pattern or to initialize a new one.  See
  203. `initialize-tooltalk-message/pattern-args' for a description of how
  204. arguments are initialized."
  205.   (let ((args attributes)
  206.     (initfn 'initialize-tooltalk-pattern-arg))
  207.     (while (and args (cdr args))
  208.       (let ((indicator (car args))
  209.         (value (car (cdr args))))
  210.     (cond
  211.      ((eq indicator 'args)
  212.       (initialize-tooltalk-message/pattern-args initfn pat value))
  213.      ((eq indicator 'plist)
  214.       (let ((values value))
  215.         (while values
  216.           (let ((prop (car values))
  217.             (propval (car (cdr values))))
  218.         (tooltalk-pattern-prop-set pat prop propval))
  219.           (setq values (cdr (cdr values))))))
  220.      ((consp value)
  221.       (let ((values value))
  222.         (while values
  223.           (add-tooltalk-pattern-attribute (car values) pat indicator)
  224.           (setq values (cdr values)))))
  225.      (t
  226.       (add-tooltalk-pattern-attribute value pat indicator))))
  227.       (setq args (cdr (cdr args))))))
  228.  
  229.  
  230.  
  231. (defun make-tooltalk-pattern (attributes)
  232.   "Create a tooltalk pattern and initialize its attributes.
  233. The value of attributes must be a list of alternating keyword/values, 
  234. where keywords are symbols that name valid pattern attributes
  235. or lists of valid attributes.  For example:
  236.  
  237.   (make-tooltalk-pattern 
  238.     '(category TT_OBSERVE
  239.       scope TT_SESSION
  240.       op (\"operation1\" \"operation2\")
  241.       args (\"arg1\" 12345 (TT_INOUT \"arg3\" \"string\"))))
  242.  
  243.  
  244. Values must always be strings, integers, or symbols that
  245. represent Tooltalk constants or lists of same.  When a list 
  246. of values is provided all of the list elements are added to 
  247. the attribute.  In the example above, messages whose op
  248. attribute is \"operation1\" or \"operation2\" would match the pattern.
  249.  
  250. The value of args should be a list of pattern arguments where 
  251. each pattern argument has the following form:
  252.  
  253.    (mode [value [type]]) or just value
  254.  
  255. Where mode is one of TT_IN, TT_OUT, TT_INOUT and type is a string.  
  256. If type isn't specified then \"int\" is used if the value is a 
  257. number otherwise \"string\" is used.  If only a value is specified 
  258. then mode defaults to TT_IN.  If mode is TT_OUT then value and type 
  259. don't need to be specified.  You can find out more about the semantics 
  260. and uses of ToolTalk pattern arguments in chapter 3 of the Tooltalk
  261. Programmers Guide.
  262. "
  263.   (let ((pat (create-tooltalk-pattern)))
  264.     (initialize-tooltalk-pattern-attributes pat attributes)
  265.     pat))
  266.  
  267.  
  268.  
  269.